以下の通りにパッケージとデータセットを用意する。 すべてのコードは、githubに公開されています。
# load library ------------------------------------------------------------
pacman::p_load("tidyverse", "janitor", "stringr", "lubridate", "patchwork", "modelr")
# import dataset --------------------------------------------------------
path_to_github <- "https://raw.githubusercontent.com/Ricky-s-a/business_analysis/main/data/ST2187_coursework_dataset_2022_23.csv"
df_raw <- read_csv(path_to_github)このデータセットは、row: x columns:となっている。
# inspect the dataset -----------------------------------------------------
glimpse(df_raw)## Rows: 51,290
## Columns: 24
## $ `Row ID` <dbl> 32298, 26341, 25330, 13524, 47221, 22732, 30570, 3119…
## $ `Order ID` <chr> "CA-2012-124891", "IN-2013-77878", "IN-2013-71249", "…
## $ `Order Date` <chr> "8/1/2019", "2/6/2020", "10/17/2020", "1/29/2020", "1…
## $ `Ship Date` <chr> "8/1/2019", "2/8/2020", "10/18/2020", "1/31/2020", "1…
## $ `Ship Mode` <chr> "Same Day", "Second Class", "First Class", "First Cla…
## $ `Customer ID` <chr> "RH-19495", "JR-16210", "CR-12730", "KM-16375", "RH-9…
## $ `Customer Name` <chr> "Rick Hansen", "Justin Ritter", "Craig Reiter", "Kath…
## $ Segment <chr> "Consumer", "Corporate", "Consumer", "Home Office", "…
## $ City <chr> "New York City", "Wollongong", "Brisbane", "Berlin", …
## $ State <chr> "New York", "New South Wales", "Queensland", "Berlin"…
## $ Country <chr> "United States", "Australia", "Australia", "Germany",…
## $ `Postal Code` <dbl> 10024, NA, NA, NA, NA, NA, NA, NA, 95823, 28027, 2230…
## $ Market <chr> "US", "APAC", "APAC", "EU", "Africa", "APAC", "APAC",…
## $ Region <chr> "East", "Oceania", "Oceania", "Central", "Africa", "O…
## $ `Product ID` <chr> "TEC-AC-10003033", "FUR-CH-10003950", "TEC-PH-1000466…
## $ Category <chr> "Technology", "Furniture", "Technology", "Technology"…
## $ `Sub-Category` <chr> "Accessories", "Chairs", "Phones", "Phones", "Copiers…
## $ `Product Name` <chr> "Plantronics CS510 - Over-the-Head monaural Wireless …
## $ Sales <dbl> 2309.650, 3709.395, 5175.171, 2892.510, 2832.960, 286…
## $ Quantity <dbl> 7, 9, 9, 5, 8, 5, 4, 6, 5, 13, 5, 5, 4, 7, 12, 4, 9, …
## $ Discount <dbl> 0.0, 0.1, 0.1, 0.1, 0.0, 0.1, 0.0, 0.0, 0.2, 0.4, 0.0…
## $ Profit <dbl> 762.1845, -288.7650, 919.9710, -96.5400, 311.5200, 76…
## $ `Shipping Cost` <dbl> 933.57, 923.63, 915.49, 910.16, 903.04, 897.35, 894.7…
## $ `Order Priority` <chr> "Critical", "Critical", "Medium", "Medium", "Critical…
すばらしいことに、postal codeにNAがあるだけで、そのほかにはまったくNAがない。
# the number of na
lapply(df_raw, function(n){sum(is.na(n))})## $`Row ID`
## [1] 0
##
## $`Order ID`
## [1] 0
##
## $`Order Date`
## [1] 0
##
## $`Ship Date`
## [1] 0
##
## $`Ship Mode`
## [1] 0
##
## $`Customer ID`
## [1] 0
##
## $`Customer Name`
## [1] 0
##
## $Segment
## [1] 0
##
## $City
## [1] 0
##
## $State
## [1] 0
##
## $Country
## [1] 0
##
## $`Postal Code`
## [1] 41296
##
## $Market
## [1] 0
##
## $Region
## [1] 0
##
## $`Product ID`
## [1] 0
##
## $Category
## [1] 0
##
## $`Sub-Category`
## [1] 0
##
## $`Product Name`
## [1] 0
##
## $Sales
## [1] 0
##
## $Quantity
## [1] 0
##
## $Discount
## [1] 0
##
## $Profit
## [1] 0
##
## $`Shipping Cost`
## [1] 0
##
## $`Order Priority`
## [1] 0
# tidy dataset ------------------------------------------------------------
df_tidy <- df_raw %>%
clean_names()
# tidy
df <- df_tidy %>%
mutate(
order_date = as.Date(order_date, format = "%m/%d/%Y"),
ship_date = as.Date(ship_date, format = "%m/%d/%Y"),
order_year = year(order_date),
order_month = month(order_date),
ship_year = year(ship_date),
ship_month = month(ship_date),
split_tf = round(runif(nrow(df_tidy), min = 1, max = 5)),
gap_date = as.numeric(difftime(ship_date, order_date, units = "days")),
profit_ratio = profit/sales
) %>%
arrange(desc(order_date))
# show
glimpse(df)## Rows: 51,290
## Columns: 31
## $ row_id <dbl> 1783, 26535, 44025, 26333, 12929, 26335, 15693, 1787, 1…
## $ order_id <chr> "MX-2014-116267", "IN-2014-43550", "RS-2014-1460", "IN-…
## $ order_date <date> 2021-12-31, 2021-12-31, 2021-12-31, 2021-12-31, 2021-1…
## $ ship_date <date> 2022-01-03, 2022-01-01, 2022-01-02, 2022-01-03, 2022-0…
## $ ship_mode <chr> "Second Class", "First Class", "Second Class", "First C…
## $ customer_id <chr> "EB-13975", "ML-17395", "PB-9105", "JD-16150", "JG-1580…
## $ customer_name <chr> "Erica Bern", "Marina Lichtenstein", "Peter Bühler", "J…
## $ segment <chr> "Corporate", "Corporate", "Consumer", "Corporate", "Cor…
## $ city <chr> "São Paulo", "Jakarta", "Ufa", "Bangkok", "Maidenhead",…
## $ state <chr> "São Paulo", "Jakarta", "Bashkortostan", "Bangkok", "En…
## $ country <chr> "Brazil", "Indonesia", "Russia", "Thailand", "United Ki…
## $ postal_code <dbl> NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, 10009, …
## $ market <chr> "LATAM", "APAC", "EMEA", "APAC", "EU", "APAC", "EU", "L…
## $ region <chr> "South", "Southeast Asia", "EMEA", "Southeast Asia", "N…
## $ product_id <chr> "TEC-CO-10000137", "FUR-BO-10004679", "TEC-HEW-10004652…
## $ category <chr> "Technology", "Furniture", "Technology", "Furniture", "…
## $ sub_category <chr> "Copiers", "Bookcases", "Copiers", "Tables", "Phones", …
## $ product_name <chr> "Canon Wireless Fax, Color", "Safco Library with Doors,…
## $ sales <dbl> 1264.4660, 1091.2806, 865.6200, 1048.7313, 867.3000, 29…
## $ quantity <dbl> 5, 3, 6, 9, 5, 3, 3, 3, 2, 9, 4, 4, 4, 5, 2, 3, 3, 4, 2…
## $ discount <dbl> 0.002, 0.070, 0.000, 0.570, 0.000, 0.270, 0.100, 0.000,…
## $ profit <dbl> 301.4660, 46.9206, 51.8400, -1195.2387, 251.4000, 68.11…
## $ shipping_cost <dbl> 253.25, 243.11, 138.18, 86.86, 53.16, 52.11, 51.79, 51.…
## $ order_priority <chr> "High", "High", "High", "High", "Medium", "High", "Medi…
## $ order_year <dbl> 2021, 2021, 2021, 2021, 2021, 2021, 2021, 2021, 2021, 2…
## $ order_month <dbl> 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12,…
## $ ship_year <dbl> 2022, 2022, 2022, 2022, 2022, 2022, 2022, 2022, 2022, 2…
## $ ship_month <dbl> 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 12, 1, 1, 1, 12, 1, 1, 1,…
## $ split_tf <dbl> 3, 1, 3, 4, 3, 4, 3, 5, 3, 1, 1, 2, 3, 5, 5, 2, 2, 4, 2…
## $ gap_date <dbl> 3, 1, 2, 3, 5, 3, 2, 3, 4, 5, 0, 4, 4, 1, 0, 4, 5, 5, 5…
## $ profit_ratio <dbl> 0.23841369, 0.04299591, 0.05988771, -1.13969965, 0.2898…
gap_date()(ship_date - order_date)で計算されている。 注目したいのは、salesの分布が非常に広いことである。上は、2.263848^{4}, 下は、0.444となっていることから、高額な買い物をする顧客と少額決済をする顧客がいることがわかる。
\[ profit = sales - cost \\ quantity \times price - cost) \]
であるため、分析の方向としては、どうしたらprofitを改善させることができるのかということを最終的な目標として設定したい。
discountに関しては内政変数であるため、その効果が実際にあったのかについての政策評価することもできるし、どうしたら利益率を改善できるのかについての政策提言もできるかもしれない。
# summary of numeric data
df %>%
select(where(is.numeric)) %>%
select(!ends_with(c("year", "month", "id", "tf", "code"))) %>%
summary()## sales quantity discount profit
## Min. : 0.444 Min. : 1.000 Min. :0.0000 Min. :-6599.98
## 1st Qu.: 30.759 1st Qu.: 2.000 1st Qu.:0.0000 1st Qu.: 0.00
## Median : 85.053 Median : 3.000 Median :0.0000 Median : 9.24
## Mean : 246.491 Mean : 3.477 Mean :0.1429 Mean : 28.61
## 3rd Qu.: 251.053 3rd Qu.: 5.000 3rd Qu.:0.2000 3rd Qu.: 36.81
## Max. :22638.480 Max. :14.000 Max. :0.8500 Max. : 8399.98
## shipping_cost gap_date profit_ratio
## Min. : 0.00 Min. :0.000 Min. :-4.73354
## 1st Qu.: 2.61 1st Qu.:3.000 1st Qu.: 0.00000
## Median : 7.79 Median :4.000 Median : 0.16918
## Mean : 26.38 Mean :3.969 Mean : 0.04743
## 3rd Qu.: 24.45 3rd Qu.:5.000 3rd Qu.: 0.33314
## Max. :933.57 Max. :7.000 Max. : 0.50000
done!
# numeric variables
num_vars <-
df %>%
select(where(is.numeric)) %>%
select(!ends_with(c("year", "month", "id", "tf", "code"))) %>%
colnames()
# define the function
# each
results <- lapply(num_vars,
FUN = function(n) {
# print(
ggplot(df, aes_string(n)) +
geom_histogram()
# )
}
)
# name the list
results <- `names<-`(results, num_vars)
# show
results## $sales
##
## $quantity
##
## $discount
##
## $profit
##
## $shipping_cost
##
## $gap_date
##
## $profit_ratio
数値データの中で唯一のコントロールできる変数だから、深ぼっていきたい。
全体の65%ぐらいが、20%未満の割引なんだな。 割引しすぎてるってのが、問題なのかも。
df$discount %>% hist()discout しすぎてネガティブになっているのは、渋くない? 特に割引率が高すぎるものは、profitがネガティブになっているものもある。 そういうものって何なんだろう?どのような財? 割引しないときは、どれくらいの利益率なのか?
もうすでにテーブルはデータから取り除いてしまって考えよう。
df %>%
filter(sub_category != "Tables") %>%
ggplot(aes(discount, profit_ratio)) +
geom_ref_line(h = 0) +
geom_jitter() +
geom_smooth(method = "lm") データのレンジは、2018年1月1日から2021年12月31日まで。
# date range
df %>%
select(ends_with("date")) %>%
select(!gap_date) %>%
lapply(range)## $order_date
## [1] "2018-01-01" "2021-12-31"
##
## $ship_date
## [1] "2018-01-03" "2022-01-07"
オーダー数とorder_idとの関係とは?これがはっきりしない。
総データのエントリー数が、row:51290なのに対して、customer_idは、1500程度しかない。 もしかしたら、繰り返し買っている顧客(お得意様)とそうでない新規顧客が存在するのではないか。 それぞれに対して別々のアプローチをとることで、利益率を改善させることができるかもしれない。
世界中の国々ついて述べるのは労力をともなうため、上位5か国とか、マーケットごとでまとめたほうがいいかもしれない。productについても同じことが言えそう。
order_priorityは、実際に利益率改善に役に立っているのか。どかも分析もできそう。
# check the number of unique categorical variables
df_tidy %>%
select(where(is.character)) %>%
lapply(unique) %>%
lapply(length)## $order_id
## [1] 25035
##
## $order_date
## [1] 1430
##
## $ship_date
## [1] 1464
##
## $ship_mode
## [1] 4
##
## $customer_id
## [1] 1590
##
## $customer_name
## [1] 795
##
## $segment
## [1] 3
##
## $city
## [1] 3636
##
## $state
## [1] 1094
##
## $country
## [1] 147
##
## $market
## [1] 7
##
## $region
## [1] 13
##
## $product_id
## [1] 10292
##
## $category
## [1] 3
##
## $sub_category
## [1] 17
##
## $product_name
## [1] 3788
##
## $order_priority
## [1] 4
気になる変数を深堀していく。
毎年11月、12月にかけてオーダー数が増えている。(?) シーズンによって商品のオーダー数が増えているかの確かめをしたほうがいいかも。 これ、オーダー数だけじゃなくて、profit, quantity, salesに対してもやったほうがいいな。
g1 <-
df %>%
mutate(colour = if_else(order_month %in% c(11, 12), "red", "blue")) %>%
group_by(order_year, order_month) %>%
ggplot() +
aes(order_date, fill = colour) +
geom_bar()
g1ざっと見た感じ、11月、12月に注文数が多くなっているのがわかる。
df %>%
group_by(order_year, order_date) %>%
summarise(total = n()) %>% filter(order_year == 2018, total > 50) ## # A tibble: 31 × 3
## # Groups: order_year [1]
## order_year order_date total
## <dbl> <date> <int>
## 1 2018 2018-03-01 53
## 2 2018 2018-06-07 60
## 3 2018 2018-06-22 55
## 4 2018 2018-08-25 53
## 5 2018 2018-09-02 60
## 6 2018 2018-09-08 76
## 7 2018 2018-09-14 63
## 8 2018 2018-09-23 54
## 9 2018 2018-09-26 56
## 10 2018 2018-09-27 57
## # … with 21 more rows
ない!
# there must be some variations in the gap between the order date and the ship date.
# Q. how is the gap between the order date and the ship date?
df %>%
ggplot(aes(gap_date, region)) +
geom_boxplot()# there must be some variations in the shipping cost across countries.
# Q. how much is that?
g_corporate <- df %>%
filter(segment == "Corporate") %>%
ggplot(aes(shipping_cost, market)) +
geom_boxplot() +
labs(title = "Corporate")
g_consumer <- df %>%
filter(segment == "Consumer") %>%
ggplot(aes(shipping_cost, market)) +
geom_boxplot() +
labs(title = "Consumer")
g_home_office <- df %>%
filter(segment == "Home Office") %>%
ggplot(aes(shipping_cost, market)) +
geom_boxplot() +
labs(title = "Home Office")
g_corporate / g_consumer / g_home_office# basic info --------------------------------------------------------------
# the ration of regions in profit on the annual basis
df %>%
group_by(order_year, order_month, region) %>%
summarise(sum_profit = sum(profit)) %>%
ggplot(aes(order_year, sum_profit, fill = region)) +
geom_col()# total profit by year
profit_by_year <-
df %>% group_by(order_year) %>%
summarise(annual_profit = sum(profit))
# profit ratio by year
df %>%
group_by(order_year, order_month, market) %>%
summarise(sum_profit = sum(profit)) %>%
mutate(profit_ratio_by_year = sum_profit/filter(profit_by_year, order_year == order_year)[[2]]) %>%
arrange(order_year, desc(sum_profit)) ## # A tibble: 335 × 5
## # Groups: order_year, order_month [48]
## order_year order_month market sum_profit profit_ratio_by_year
## <dbl> <dbl> <chr> <dbl> <dbl>
## 1 2018 9 EU 13805. 0.0555
## 2 2018 12 APAC 13516. 0.0442
## 3 2018 10 APAC 13496. 0.0441
## 4 2018 12 EU 11540. 0.0464
## 5 2018 11 US 9292. 0.0228
## 6 2018 6 APAC 9216. 0.0301
## 7 2018 12 US 8984. 0.0220
## 8 2018 11 APAC 8951. 0.0293
## 9 2018 9 US 8328. 0.0204
## 10 2018 6 EU 7799. 0.0313
## # … with 325 more rows
Especially the markets in APAc and EU are expanding.
# Q. the most profitable market, product, category, sub_category,
df %>%
group_by(order_year, market) %>%
summarise(profit = sum(profit)) %>%
arrange(order_year,desc(profit)) %>%
top_n(5, profit)## # A tibble: 20 × 3
## # Groups: order_year [4]
## order_year market profit
## <dbl> <chr> <dbl>
## 1 2018 APAC 83032.
## 2 2018 EU 61626.
## 3 2018 US 49544.
## 4 2018 LATAM 36708.
## 5 2018 Africa 10944.
## 6 2019 APAC 89321.
## 7 2019 EU 83775.
## 8 2019 US 61180.
## 9 2019 LATAM 49524.
## 10 2019 Africa 11909.
## 11 2020 APAC 123193.
## 12 2020 EU 98484.
## 13 2020 US 82165.
## 14 2020 LATAM 62077.
## 15 2020 Africa 26687.
## 16 2021 APAC 140454.
## 17 2021 EU 128944.
## 18 2021 US 93508.
## 19 2021 LATAM 73335.
## 20 2021 Africa 39331.
The presence of China and India is growing.
# Q. which country?
df %>%
filter(market %in% c("APAC", "EU")) %>%
group_by(order_year, country) %>%
summarise(market_profit = sum(profit)) %>%
arrange(order_year, desc(market_profit)) %>%
top_n(3, market_profit)## # A tibble: 12 × 3
## # Groups: order_year [4]
## order_year country market_profit
## <dbl> <chr> <dbl>
## 1 2018 China 33181.
## 2 2018 United Kingdom 20080.
## 3 2018 India 19929.
## 4 2019 United Kingdom 27366.
## 5 2019 India 27329.
## 6 2019 China 26234.
## 7 2020 China 44474.
## 8 2020 India 33007.
## 9 2020 France 32316.
## 10 2021 India 48808.
## 11 2021 China 46794.
## 12 2021 United Kingdom 36756.
technology, furniture, office suplliesで変らない。
# which category is sold in those region?
df %>%
filter(country %in% c("India", "China")) %>%
group_by(order_year, sub_category) %>%
summarise(profit_by_subcategory = sum(profit)) %>%
arrange(order_year, desc(profit_by_subcategory)) %>%
top_n(10, desc(profit_by_subcategory)) ## # A tibble: 40 × 3
## # Groups: order_year [4]
## order_year sub_category profit_by_subcategory
## <dbl> <chr> <dbl>
## 1 2018 Machines 2599.
## 2 2018 Furnishings 2008.
## 3 2018 Envelopes 1187.
## 4 2018 Supplies 1073.
## 5 2018 Binders 1022.
## 6 2018 Art 819.
## 7 2018 Paper 763.
## 8 2018 Fasteners 478.
## 9 2018 Labels 224.
## 10 2018 Tables -1465.
## # … with 30 more rows
いるが、それぞれがバラバラ。もっとフォローアップを増やし、one-timeではなく、継続的な大手取引先を作るべき。
df %>%
group_by(order_year, customer_id) %>%
summarise(profit_by_customer = sum(profit)) %>%
arrange(order_year, desc(profit_by_customer)) %>%
top_n(10, profit_by_customer) ## # A tibble: 40 × 3
## # Groups: order_year [4]
## order_year customer_id profit_by_customer
## <dbl> <chr> <dbl>
## 1 2018 SC-20095 5716.
## 2 2018 CA-11965 3121.
## 3 2018 NM-18445 2950.
## 4 2018 GT-14710 2909.
## 5 2018 ON-18715 2689.
## 6 2018 ER-13855 2618.
## 7 2018 TB-21400 2549.
## 8 2018 KN-16390 2453.
## 9 2018 HL-15040 2405.
## 10 2018 RB-19330 2238.
## # … with 30 more rows
ggplot(df, aes(x =))# top10 customers customer's id for every year.
major_customers <-
df %>%
group_by(order_year, customer_id) %>%
summarise(profit_by_customer = sum(profit)) %>%
arrange(order_year, desc(profit_by_customer)) %>%
top_n(10, profit_by_customer) %>%
ungroup() %>%
select(customer_id) %>%
unlist() %>%
unname()
df %>%
filter(customer_id %in% major_customers) %>%
group_by(order_year, customer_id, sub_category) %>%
summarise(profit_by_subcategory = sum(profit)) %>%
arrange(order_year, desc(profit_by_subcategory)) %>%
top_n(1, profit_by_subcategory)## # A tibble: 152 × 4
## # Groups: order_year, customer_id [152]
## order_year customer_id sub_category profit_by_subcategory
## <dbl> <chr> <chr> <dbl>
## 1 2018 SC-20095 Binders 5480.
## 2 2018 CA-11965 Phones 2939.
## 3 2018 ER-13855 Appliances 2476.
## 4 2018 TB-21400 Machines 2240.
## 5 2018 ON-18715 Chairs 2125.
## 6 2018 NM-18445 Machines 1996.
## 7 2018 HL-15040 Phones 1930.
## 8 2018 DR-12940 Appliances 1644.
## 9 2018 KN-16390 Tables 1528.
## 10 2018 GT-14710 Chairs 1474.
## # … with 142 more rows
これはtabuleauでやったほうが早いかも。
売り上げは毎年上昇している。そして利益も上昇している。ここには問題はなさそう。 ただ、利益率は下がっているように見える。
df_tem <-
df %>%
group_by(order_year) %>%
summarise(sales_year = sum(sales), shipping_cost_year = sum(shipping_cost), profit_year = sum(profit)) %>%
pivot_longer(cols = c(sales_year, shipping_cost_year, profit_year), names_to = "vars", values_to = "value") %>%
mutate(vars = factor(vars, levels = c("sales_year", "shipping_cost_year", "profit_year")))
g_pg1_1 <-
df_tem %>%
filter(vars == "sales_year") %>%
ggplot(aes(x = factor(order_year), y = value, group = vars), colour = "green") +
geom_point() +
geom_line() +
scale_y_continuous(labels = scales::label_number(accracy = 1))
g_pg1_2 <-
df_tem %>%
filter(vars %in% c("shipping_cost_year", "profit_year")) %>%
ggplot(aes(x = factor(order_year), y = value, colour = vars, group = vars)) +
geom_point() +
geom_line() +
scale_y_continuous(labels = scales::label_number(accuracy = 1))
g_pg1_1 / g_pg1_23年で2倍程度になっている。目覚ましい成長。ってことは、qには問題がなさそう。
df %>%
group_by(order_year) %>%
summarise(quantity_year = sum(quantity)) %>%
ggplot(aes(order_year, quantity_year)) +
geom_point() +
geom_line() +
scale_y_continuous(labels = scales::number_format(accuracy = 1))言うほど利益率が上昇している感じでもないのかな。 0.110あたりで推移しているイメージ。 salesの値が上昇しているから、コストが上昇しているわけではないのか。あくまでも比例的にprofitはsalesに対して伸びているのか。 ってことは、規模の経済が働いていない可能性を示唆している。
利益率を改善するにはってのが、一つの課題ではあるな。
g_pg1_3 <-
df %>%
group_by(order_year) %>%
summarise(profit_ratio_year = sum(profit)/sum(sales)) %>%
ggplot(aes(order_year, profit_ratio_year)) +
geom_point() +
geom_line()
g_pg1_3table <-
df %>%
group_by(order_year, sub_category) %>%
summarise(profit_ratio_year = sum(profit)/sum(sales)) %>%
arrange(order_year, desc(profit_ratio_year))
# show the table
DT::datatable(table,
rownames = FALSE,
extensions = 'Buttons',
options = list(autoWidth = TRUE,
pageLength = 5,
dom = 'Bfrtip',
buttons = list("csv"),
scrollX = TRUE,
scrollCollapse = TRUE),
class = 'cell-border stripe'
)テーブルがありえんくらい利益率低いな。 これ売らないほうがいいんじゃない?
# graph
g_pg2_1 <-
table %>%
ggplot(aes(factor(order_year), profit_ratio_year, colour = sub_category, group = sub_category)) +
geom_point() +
geom_line()
plotly::ggplotly(g_pg2_1)テーブルの販売はやめたほうがいいですね。
g_pg2_2 <-
df %>%
group_by(order_year) %>%
summarise(profit_ratio_year_with = sum(profit)/sum(sales)) %>%
left_join(by = "order_year",
df %>%
filter(sub_category != "Tables") %>%
group_by(order_year) %>%
summarise(profit_ratio_year_without = sum(profit)/sum(sales))
) %>%
pivot_longer(cols = c(profit_ratio_year_with, profit_ratio_year_without)) %>%
ggplot(aes(order_year, value, colour = name, group = name)) +
geom_point() +
geom_line(aes(linetype = name))
# show
g_pg2_2さすがに利益自体は減ってしまうのか。 テーブルを売るお金をほかの在庫に回せた場合、って分析もありかな? テーブルに使ったお金(sales)がほかの商品であった場合、というか、平均的な利益率を達成した場合の利益の増加分を計測してみようかな。
あと、これ月ごとの分析にしてもいいかもしれない。
g_pg2_3 <-
df %>%
group_by(order_year) %>%
summarise(profit_year_with = sum(profit)) %>%
left_join(by = "order_year",
df %>%
filter(sub_category != "Tables") %>%
group_by(order_year) %>%
summarise(profit_year_without = sum(profit))
) %>%
pivot_longer(cols = c(profit_year_with, profit_year_without)) %>%
ggplot(aes(order_year, value, colour = name, group = name)) +
geom_point() +
geom_line(aes(linetype = name)) +
scale_y_continuous(labels = scales::number_format(accuracy = 1))
# show
g_pg2_3テーブルは、もうないものとして考えよう。(いや、やっぱり入れておこう) それでも、discoutが大きくなると、profit_ratioが少なくなってしまう傾向があるな。 つまり、全体的に言って、財の種類でいうと非弾力的ってことかな? もしかしたら、値段を上げたほうが利益率は改善するのかもしれない。
g_pg3_1 <-
df %>%
# filter(sub_category != "Tables") %>%
ggplot(aes(discount, profit_ratio)) +
geom_ref_line(h = 0) +
geom_jitter() +
geom_smooth(method = "lm")
g_pg3_1これは、全体的に同じ傾向か。
df %>%
# filter(sub_category != "Tables") %>%
ggplot(aes(discount, profit_ratio, colour = sub_category)) +
geom_ref_line(h = 0) +
geom_jitter() +
geom_smooth(method = "lm") +
facet_wrap(vars(sub_category)) +
theme(legend.position = "none")実際に、このデータからわかることは、価格の変動に対して需要が非弾力的。
df %>%
filter(sub_category != "Tables") %>%
ggplot(aes(discount, quantity, colour = sub_category)) +
geom_ref_line(h = 0) +
geom_jitter() +
geom_smooth(method = "lm") +
facet_wrap(vars(sub_category)) +
theme(legend.position = "none")profitのほうが見ていて面白そうだな。 結局、discountにかかわらず、利益が変わらないから意味がないって言えるしね。
df %>%
filter(sub_category != "Tables") %>%
ggplot(aes(discount, profit, colour = sub_category)) +
geom_ref_line(h = 0) +
geom_jitter() +
geom_smooth(method = "lm") +
facet_wrap(vars(sub_category)) +
theme(legend.position = "none")下の図は、discountを説明変数とし、quantityを被説明変数としたときの単回帰分析をした時の係数を入れてある。
関しては、discoutをしようが、しまいが、quantityが変わっていない。つまり、95%信頼区間の中で、discoutをしても意味がないといえるだろう。
これ、年ごとのやつを作ってもいいかもしれないな。
ただし、売れない商品をもしかしたらdiscountしているのかもしれないため、discountしたから、売上数量が減ったという原因と結果を表しているわけではないことに注意するべきである。
# nest the dataeset based on the sub_category
df_lm <- df %>%
group_by(sub_category) %>%
nest()
# name the columns
names(df_lm$data) <- df_lm$sub_category # name the list of the data in df_lm
# run the regression
df_lm <- df_lm %>%
mutate(model = purrr::map(data, ~ estimatr::lm_robust(quantity ~ discount, data = .))) # run the robust regression
# create vars for plotting data
coefficient <- c()
p_value <- c()
sd_error <- c()
for (i in 1:length(df_lm$sub_category)) {
coefficient[i] <- df_lm$model[i][[1]]$coefficients[2]
p_value[i] <- df_lm$model[i][[1]]$p.value[2]
sd_error[i] <- df_lm$model[i][[1]]$std.error[2]
}
# create a data frame for plotting error bar
df_graphics <- tibble(
sub_category = df_lm$sub_category,
coefficient = coefficient,
p_value = p_value,
sd_error = sd_error,
ci_lower = coefficient - 1.96*sd_error,
ci_upper = coefficient + 1.96*sd_error,
p_logical = if_else(p_value > 0.05, "p>0.05", "p<=0.05")
) %>%
left_join(df %>% group_by(sub_category) %>% summarise(profit_ratio = sum(profit)/sum(sales))) # add profit ratio
# plot with ggplot2
df_graphics %>%
ggplot(aes(profit_ratio,
coefficient,
colour = p_logical)) +
geom_point() +
geom_hline(yintercept = 0, alpha = 0.25, linetype = "dashed") +
geom_errorbar(aes(ymin = ci_lower, ymax = ci_upper)) +
ggrepel::geom_text_repel(aes(label = df_lm$sub_category), check_overlap = TRUE) +
scale_color_manual(values = c("#ff9980", "#33ccff")) +
labs(title = "quantity = Beta_0 + Beta_1 * discount + epsilon",
subtitle = str_wrap("", 80),
x = "Profit Ratio",
y = "Coefficient (annual quantity)",
) +
theme_minimal() +
theme(legend.position = "right")下の図は、discountを説明変数とし、profitを被説明変数としたときの単回帰分析をした時の係数を入れてある。 discountによって確実に利益は下がっている。これは、おおよそpriceが下がってしまっているからだろう。 しかし、価格弾力的な材に関しては、cost一定だと仮定すると、priceの上昇によって、
ほとんどの商品に関して、discoutをしようが、しまいが、profitが変わっていない。つまり、95%信頼区間の中で、discoutをしても意味がないといえるだろう。
# nest the dataeset based on the sub_category
df_lm <- df %>%
group_by(sub_category) %>%
nest()
# name the columns
names(df_lm$data) <- df_lm$sub_category # name the list of the data in df_lm
# run the regression
df_lm <- df_lm %>%
mutate(model = purrr::map(data, ~ estimatr::lm_robust(profit ~ discount, data = .))) # run the robust regression
# create vars for plotting data
coefficient <- c()
p_value <- c()
sd_error <- c()
for (i in 1:length(df_lm$sub_category)) {
coefficient[i] <- df_lm$model[i][[1]]$coefficients[2]
p_value[i] <- df_lm$model[i][[1]]$p.value[2]
sd_error[i] <- df_lm$model[i][[1]]$std.error[2]
}
# create a data frame for plotting error bar
df_graphics <- tibble(
sub_category = df_lm$sub_category,
coefficient = coefficient,
p_value = p_value,
sd_error = sd_error,
ci_lower = coefficient - 1.96*sd_error,
ci_upper = coefficient + 1.96*sd_error,
p_logical = if_else(p_value > 0.05, "p>0.05", "p<=0.05")
) %>%
left_join(df %>% group_by(sub_category) %>% summarise(profit_ratio = sum(profit)/sum(sales))) # add profit ratio
# plot with ggplot2
df_graphics %>%
ggplot(aes(profit_ratio,
coefficient,
colour = p_logical)) +
geom_point() +
geom_hline(yintercept = 0, alpha = 0.25, linetype = "dashed") +
geom_errorbar(aes(ymin = ci_lower, ymax = ci_upper)) +
ggrepel::geom_text_repel(aes(label = df_lm$sub_category), check_overlap = TRUE) +
scale_color_manual(values = c("#ff9980", "#33ccff")) +
labs(title = "profit = Beta_0 + Beta_1 * discount + epsilon",
subtitle = str_wrap("", 80),
x = "Profit Ratio",
y = "Coefficient (annual profit)",
) +
theme_minimal() +
theme(legend.position = "right")興味のある方は以下のQRコードを参照して、サイトにアクセスしてみてください。
qrcode::qr_code("https://htmlpreview.github.io/?https://raw.githubusercontent.com/Ricky-s-a/business_analysis/main/report/prep_for_coursework_2022_23.html") %>% plot()